00100	(DEFPROP COMPACTION EVAL DEFACTION)
00200	
00300	(DEFPROP OCTAL (LAMBDA (X) (PROG2 (EVAL X) (FLUSHEXPR X))) COMPACTION)
00400	
00500	(DEFPROP DECIMAL (LAMBDA (X) (PROG2 (EVAL X) (FLUSHEXPR X))) COMPACTION)
00600	
00700	(OCTAL)
00800	
00900	(DECLARE (SPECIAL PRINTIT LIMCARRY EITHEROR ROTSIZ MARG1 MARG2 MARG3)
01000		 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT *LP *RP *SL *AM *AT *RO *COLON)
01100		 (SPECIAL IBASE BASE *NOPOINT INUM0))
01200	
01300	(DM (WHILE L)
01400	    (APPEND (QUOTE (PROG NIL LOOP))
01500		    (LIST (LIST	(QUOTE COND)
01600				(LIST (LIST (QUOTE NOT) (CADR L))
01700				      (QUOTE (RETURN NIL)))))
01800		    (CDDR L)
01900		    (QUOTE ((GO LOOP)))))
02000	
02100	(DE (ROTORSTEP PRINTIT ROTORS STARTS)
02200	 (PROG (POSITS1 POSITS1SAV POSITS2 POSITS2SAV ROTS SIZES INITSKIPS
02300	        CARRIES COUNT NEWPOS OLDPOS POSDIF)
02400	       (SETQ ROTORS (REVERSE ROTORS))
02500	       (SETQ STARTS (REVERSE STARTS))
02600	       (SETQ COUNT -1)
02700	       (SETQ SIZES (MAPCAR (FUNCTION CAR) ROTORS))
02800	       (SETQ INITSKIPS (MAPCAR (FUNCTION CAADR) ROTORS))
02900	       (SETQ CARRIES (MAPCAR (FUNCTION CADADR) ROTORS))
03000	       (SETQ ROTS (MAPCAR (FUNCTION CDDR) ROTORS))
03100	       (SETQ POSITS1 (SETUP ROTS STARTS))
03200	       (SETQ POSITS2 POSITS1)
03300	  LOOP (SETQ COUNT (ADD1 COUNT))
03400	       (COND (PRINTIT (PRINT COUNT)
03500			      (PRINC *TB)
03600			      (PRINC (SETQ NEWPOS (MAPCAR (FUNCTION CAAR)
03700							  (REVERSE POSITS1))))
03800			      (TABTO MARG1)
03900			      (COND (OLDPOS (PRINC (SETQ POSDIF
04000							 (MODVECDIF NEWPOS
04100								    OLDPOS
04200								    SIZES)))
04300					    (TABTO MARG2)
04400					    (PRIN1 (MODDERIV POSDIF
04500							     SIZES))
04600					    (TABTO MARG3)
04700					    (PRIN1 (HAMWEIGHT POSDIF))))))
04800	       (SETQ OLDPOS NEWPOS)
04900	       (SETQ POSITS1SAV POSITS1)
05000	       (SETQ POSITS1 (ONESTEP POSITS1 ROTS INITSKIPS CARRIES))
05100	       (COND (FLOYDTEST
05200		      (SETQ POSITS2SAV POSITS2)
05300		      (COND (PRINTIT (PRINT (MAPCAR (FUNCTION CAAR) (REVERSE POSITS1)))))
05400		      (SETQ POSITS2 (ONESTEP POSITS2 ROTS INITSKIPS CARRIES))
05500		      (COND (PRINTIT (PRINC (MAPCAR (FUNCTION CAAR) (REVERSE POSITS2)))))
05600		      (SETQ POSITS2 (ONESTEP POSITS2 ROTS INITSKIPS CARRIES))
05700		      (COND (PRINTIT (PRINC (MAPCAR (FUNCTION CAAR) (REVERSE POSITS2)))))
05800		      (COND ((EQUAL POSITS1 POSITS2)
05900			     (PRINT (LIST (MAPCAR (FUNCTION CAAR) POSITS1SAV)
06000					  (MAPCAR (FUNCTION CAAR) POSITS2SAV)))
06100			     (RETURN (ADD1 COUNT)))))
06200		     (T (COND ((EQUAL POSITS1 ROTS) (RETURN (ADD1 COUNT))))))
06300	       (GO LOOP)))
06400	
     

00100	(DE (ONESTEP POSITS ROTS INITSKIPS CARRYSKIPS)
00200	 (PROG (ANS POSIT ROT INITSKIP CARRYSKIP KICKSIN KICKSOUT)
00300	       (SETQ KICKSIN 0)
00400	       (SETQ KICKSOUT 0)
00500	       (WHILE POSITS
00600		      (COND (LIMCARRY (SETQ KICKSOUT 0)))
00700		      (SETQ POSIT (CAR POSITS))
00800		      (SETQ ROT (CAR ROTS))
00900		      (SETQ INITSKIP (CAR INITSKIPS))
01000		      (COND ((AND EITHEROR (NOT (ZEROP KICKSIN)))
01100			     (SETQ INITSKIP 0)))
01200		      (WHILE (GREATERP INITSKIP 0)
01300			     (COND ((NOT (ZEROP (CADAR POSIT)))
01400				    (SETQ POSIT (CDR POSIT))))
01500			     (COND ((NULL POSIT) (SETQ POSIT ROT)))
01600			     (COND ((NOT (ZEROP (CADDAR POSIT)))
01700				    (SETQ KICKSOUT (ADD1 KICKSOUT))))
01800			     (SETQ INITSKIP (SUB1 INITSKIP)))
01900		      (WHILE (GREATERP KICKSIN 0)
02000			     (SETQ CARRYSKIP (CAR CARRYSKIPS))
02100			     (WHILE (GREATERP CARRYSKIP 0)
02200				    (SETQ POSIT (CDR POSIT))
02300				    (COND ((NULL POSIT) (SETQ POSIT ROT)))
02400				    (COND ((NOT (ZEROP (CADDAR POSIT)))
02500					   (SETQ KICKSOUT (ADD1 KICKSOUT))))
02600				    (SETQ CARRYSKIP (SUB1 CARRYSKIP)))
02700			     (SETQ KICKSIN (SUB1 KICKSIN)))
02800		      (SETQ ANS (CONS POSIT ANS))
02900		      (SETQ KICKSIN KICKSOUT)
03000		      (SETQ POSITS (CDR POSITS))
03100		      (SETQ ROTS (CDR ROTS))
03200		      (SETQ INITSKIPS (CDR INITSKIPS))
03300		      (SETQ CARRYSKIPS (CDR CARRYSKIPS)))
03400	       (RETURN (REVERSE ANS))))
03500	
03600	(DE (*MAX X Y) (COND ((*GREAT X Y) X) (T Y)))
03700	
03800	(DE (*MIN X Y) (COND ((*LESS X Y) X) (T Y)))
03900	
04000	(DE (ZEROLIST N)
04100	    (COND ((ZEROP N) NIL) (T (CONS 0 (ZEROLIST (SUB1 N))))))
04200	
04300	(DE (ALLZERO L)
04400	    (OR (NULL L) (AND (ZEROP (CAR L)) (ALLZERO (CDR L)))))
04500	
04600	(DE (HAMWEIGHT L)
04700	    (COND ((NULL L) 0)
04800		  ((ZEROP (CAR L)) (HAMWEIGHT (CDR L)))
04900		  (T (ADD1 (HAMWEIGHT (CDR L))))))
05000	
05100	(DE (MODABSDIF X Y M) (COND ((*LESS X Y) (*DIF Y X)) (T (*DIF X Y))))
05200	
05300	(DE (MODVECDIF X Y M)
05400	    (PROG (Z)
05500	     LOOP (COND ((NULL X) (RETURN (REVERSE Z))))
05600		  (SETQ Z (CONS (MODDIF (CAR X) (CAR Y) (CAR M)) Z))
05700		  (SETQ X (CDR X))
05800		  (SETQ Y (CDR Y))
05900		  (SETQ M (CDR M))
06000		  (GO LOOP)))
06100	
06200	(DE (MODDERIV V S)
06300	    (PROG (ANS)
06400		  (WHILE (CDR V)
06500			 (SETQ ANS (CONS (MODABSDIF (CADR V)
06600						 (CAR V)
06700						 (*MAX (CAR S) (CADR S)))
06800					 ANS))
06900			 (SETQ V (CDR V)))
07000		  (RETURN (REVERSE ANS))))
07100	
07200	(DE (MODDIF X Y M)
07300	    ((LAMBDA (Z) (*MIN Z (*DIF M Z)))
07400	     (COND ((*LESS X Y) (*DIF Y X)) (T (*DIF X Y)))))
07500	
07600	(DE (MODDIF X Y M)
07700	    (COND ((*LESS X Y) (*DIF M (*DIF Y X))) (T (*DIF X Y))))
07800	
07900	(DE (CURCOL) (DIFFERENCE (ADD1 (LINELENGTH NIL)) (CHRCT)))
08000	
     

00100	(DE (PRINTN CHAR NUM)
00200	    (PROG (NO)
00300		  (SETQ NO 1)
00400	     LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
00500		  (PRINC CHAR)
00600		  (SETQ NO (ADD1 NO))
00700		  (GO LOOP)))
00800	
00900	(DE (TABTO COL)
01000	    (PROG NIL
01100		  (COND ((GREATERP (CURCOL) COL) (LINEF 1)))
01200		  (PRINTN *TB
01300			  (DIFFERENCE (LSH (SUB1 COL) -3)
01400				      (LSH (SUB1 (CURCOL)) -3)))
01500		  (PRINTN *SP (DIFFERENCE COL (CURCOL)))))
01600	
01700	(SETQ *TB (ASCII 11))
01800	
01900	(SETQ *SP (ASCII 40))
02000	
02100	(SETQ PRINTIT T)
02200	
02300	(PROG NIL
02400	      (PRINT *TB)
02500	      (PRINC @ ********)
02600	      (PRINC *SP)
02700	      (PRINC @ PRINTIT)
02800	      (PRINC *SP)
02900	      (PRINC @ LOC)
03000	      (PRINC *SP)
03100	      (PRINC @IS)
03200	      (PRINC *SP)
03300	      (PRINC (MAKNUM  (GET @ PRINTIT @ VALUE) @ FIXNUM))
03400	      (PRINC *SP)
03500	      (PRINC @ ********))
03600	
03700	(SETQ LIMCARRY T)
03800	
03900	(SETQ EITHEROR T)
04000	
04100	(SETQ FLOYDTEST T)
04200	
04300	(DECIMAL)
04400	
04500	(SETQ *NOPOINT T)
04600	
04700	(SETQ MARG1 30)
04800	
04900	(SETQ MARG2 50)
05000	
05100	(SETQ MARG3 65)
05200	
05300	(DE (SETUP ROTORS STARTS)
05400	 (PROG (ANS ROT)
05500	       (WHILE (AND (NOT (NULL ROTORS)) (NOT (NULL STARTS)))
05600		      (SETQ ROT (CAR ROTORS))
05700		      (WHILE (AND (NOT (NULL ROT))
05800				  (NOT (EQ (CAAR ROT) (CAR STARTS))))
05900			     (SETQ ROT (CDR ROT)))
06000		      (SETQ ANS (CONS ROT ANS))
06100		      (SETQ ROTORS (CDR ROTORS))
06200		      (SETQ STARTS (CDR STARTS)))
06300	       (RETURN (REVERSE ANS))))
06400